home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / usenet / sources / volume90 / aplictns / xscheme2 / part01 / Src / xsinit.c < prev    next >
C/C++ Source or Header  |  1990-04-14  |  8KB  |  231 lines
  1. /* xsinit.c - xscheme initialization routines */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7. #include "xsbcode.h"
  8.  
  9. /* macro to store a byte into a bytecode vector */
  10. #define pb(x)    (*bcode++ = (x))
  11.  
  12. /* global variables */
  13. LVAL lk_optional,lk_rest;
  14. LVAL obarray,true,eof_object,default_object,s_unassigned;
  15. LVAL cs_map1,cs_foreach1,cs_withfile1,cs_load1,cs_force1;
  16. LVAL c_lpar,c_rpar,c_dot,c_quote,s_quote;
  17. LVAL s_eval,s_unbound,s_stdin,s_stdout,s_stderr;
  18. LVAL s_printcase,k_upcase,k_downcase;
  19. LVAL s_fixfmt,s_flofmt;
  20.  
  21. /* external variables */
  22. extern jmp_buf top_level;
  23. extern FUNDEF funtab[];
  24. extern int xsubrcnt;
  25. extern int csubrcnt;
  26.  
  27. /* xlinitws - create an initial workspace */
  28. xlinitws(ssize)
  29.   unsigned int ssize;
  30. {
  31.     unsigned char *bcode;
  32.     int type,i;
  33.     LVAL code;
  34.     FUNDEF *p;
  35.  
  36.     /* allocate memory for the workspace */
  37.     xlminit(ssize);
  38.  
  39.     /* initialize the obarray */
  40.     s_unbound = NIL; /* to make cvsymbol work */
  41.     obarray = cvsymbol("*OBARRAY*");
  42.     setvalue(obarray,newvector(HSIZE));
  43.  
  44.     /* add the symbol *OBARRAY* to the obarray */
  45.     setelement(getvalue(obarray),
  46.                hash(getstring(getpname(obarray)),HSIZE),
  47.                cons(obarray,NIL));
  48.  
  49.     /* enter the eof object */
  50.     eof_object = cons(xlenter("**EOF**"),NIL);
  51.     
  52.     /* enter the default object */
  53.     default_object = cons(xlenter("**DEFAULT**"),NIL);
  54.  
  55.     /* initialize the error handlers */
  56.     setvalue(xlenter("*ERROR-HANDLER*"),NIL);
  57.     setvalue(xlenter("*UNBOUND-HANDLER*"),NIL);
  58.     
  59.     /* install the built-in functions */
  60.     for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p) {
  61.     type = (i < xsubrcnt ? XSUBR : (i < csubrcnt ? CSUBR : SUBR));
  62.     xlsubr(p->fd_name,type,p->fd_subr,i);
  63.     }
  64.     xloinit(); /* initialize xsobj.c */
  65.  
  66.     /* setup some synonyms */
  67.     setvalue(xlenter("NOT"),getvalue(xlenter("NULL?")));
  68.     setvalue(xlenter("PRIN1"),getvalue(xlenter("WRITE")));
  69.     setvalue(xlenter("PRINC"),getvalue(xlenter("DISPLAY")));
  70.  
  71.     /* enter all of the symbols used by the runtime system */
  72.     xlsymbols();
  73.  
  74.     /* set the initial values of the symbols #T, T and NIL */
  75.     setvalue(true,true);
  76.     setvalue(xlenter("T"),true);
  77.     setvalue(xlenter("NIL"),NIL);
  78.  
  79.     /* default to lowercase output of symbols */
  80.     setvalue(s_printcase,k_downcase);
  81.  
  82.     /* setup the print formats for numbers */
  83.     s_fixfmt = xlenter("*FIXNUM-FORMAT*");
  84.     setvalue(s_fixfmt,cvstring(IFMT));
  85.     s_flofmt = xlenter("*FLONUM-FORMAT*");
  86.     setvalue(s_flofmt,cvstring(FFMT));
  87.     
  88.     /* build the 'eval' function */
  89.     code = newcode(4); cpush(code);
  90.     setelement(code,0,newstring(0x12));
  91.     setelement(code,1,xlenter("EVAL"));
  92.     setelement(code,2,cons(xlenter("X"),NIL));
  93.     setelement(code,3,xlenter("COMPILE"));
  94.     drop(1);
  95.  
  96.     /* store the byte codes */
  97.     bcode = (unsigned char *)getstring(getbcode(code));
  98.  
  99. pb(OP_FRAME);pb(0x02);        /* 0000 12 02    FRAME 02        */
  100. pb(OP_MVARG);pb(0x01);        /* 0002 13 01    MVARG 01        */
  101. pb(OP_ALAST);            /* 0004 1a       ALAST            */
  102. pb(OP_SAVE);pb(0x00);pb(0x10);    /* 0005 0b 00 10 SAVE 0010        */
  103. pb(OP_EREF);pb(0x00);pb(0x01);    /* 0008 09 00 01 EREF 00 01 ; x        */
  104. pb(OP_PUSH);            /* 000b 10       PUSH            */
  105. pb(OP_GREF);pb(0x03);        /* 000c 05 03    GREF 03 ; compile    */
  106. pb(OP_CALL);pb(0x01);        /* 000e 0c 01    CALL 01        */
  107. pb(OP_CALL);pb(0x00);        /* 0010 0c 00    CALL 00        */
  108.  
  109.     setvalue(getelement(code,1),cvclosure(code,NIL));
  110.  
  111.     /* setup the initialization code */
  112.     code = newcode(6); cpush(code);
  113.     setelement(code,0,newstring(0x11));
  114.     setelement(code,1,xlenter("*INITIALIZE*"));
  115.     setelement(code,3,cvstring("xscheme.ini"));
  116.     setelement(code,4,xlenter("LOAD"));
  117.     setelement(code,5,xlenter("*TOPLEVEL*"));
  118.     drop(1);
  119.  
  120.     /* store the byte codes */
  121.     bcode = (unsigned char *)getstring(getbcode(code));
  122.  
  123. pb(OP_FRAME);pb(0x01);        /* 0000 12 01    FRAME 01        */
  124. pb(OP_ALAST);            /* 0002 1a       ALAST            */
  125. pb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d        */
  126. pb(OP_LIT);  pb(0x03);        /* 0006 04 03    LIT 03 ; "xscheme.ini"    */
  127. pb(OP_PUSH);            /* 0008 10       PUSH            */
  128. pb(OP_GREF); pb(0x04);        /* 0009 05 04    GREF 04 ; load        */
  129. pb(OP_CALL); pb(0x01);        /* 000b 0c 01    CALL 01        */
  130. pb(OP_GREF); pb(0x05);        /* 000d 05 05    GREF 05 ; *toplevel*    */
  131. pb(OP_CALL); pb(0x00);        /* 000f 0c 00    CALL 00        */
  132.  
  133.     setvalue(getelement(code,1),cvclosure(code,NIL));
  134.  
  135.     /* setup the main loop code */
  136.     code = newcode(9); cpush(code);
  137.     setelement(code,0,newstring(0x28));
  138.     setelement(code,1,xlenter("*TOPLEVEL*"));
  139.     setelement(code,3,cvstring("\n> "));
  140.     setelement(code,4,xlenter("DISPLAY"));
  141.     setelement(code,5,xlenter("READ"));
  142.     setelement(code,6,xlenter("EVAL"));
  143.     setelement(code,7,xlenter("WRITE"));
  144.     setelement(code,8,xlenter("*TOPLEVEL*"));
  145.     drop(1);
  146.  
  147.     /* store the byte codes */
  148.     bcode = (unsigned char *)getstring(getbcode(code));
  149.  
  150. pb(OP_FRAME);pb(0x01);        /* 0000 12 01    FRAME 01        */
  151. pb(OP_ALAST);            /* 0002 1a       ALAST            */
  152. pb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d        */
  153. pb(OP_LIT);  pb(0x03);        /* 0006 04 03    LIT 03 ; "\n> "        */
  154. pb(OP_PUSH);            /* 0008 10       PUSH            */
  155. pb(OP_GREF); pb(0x04);        /* 0009 05 04    GREF 04 ; display    */
  156. pb(OP_CALL); pb(0x01);        /* 000b 0c 01    CALL 01        */
  157. pb(OP_SAVE); pb(0x00); pb(0x24);/* 000d 0b 00 24 SAVE 0024        */
  158. pb(OP_SAVE); pb(0x00); pb(0x1f);/* 0010 0b 00 1f SAVE 001f        */
  159. pb(OP_SAVE); pb(0x00); pb(0x1a);/* 0013 0b 00 1a SAVE 001a        */
  160. pb(OP_GREF); pb(0x05);        /* 0016 05 05    GREF 05 ; read        */
  161. pb(OP_CALL); pb(0x00);        /* 0018 0c 00    CALL 00        */
  162. pb(OP_PUSH);            /* 001a 10       PUSH            */
  163. pb(OP_GREF); pb(0x06);        /* 001b 05 06    GREF 06 ; eval        */
  164. pb(OP_CALL); pb(0x01);        /* 001d 0c 01    CALL 01        */
  165. pb(OP_PUSH);            /* 001f 10       PUSH            */
  166. pb(OP_GREF); pb(0x07);        /* 0020 05 07    GREF 07 ; write    */
  167. pb(OP_CALL); pb(0x01);        /* 0022 0c 01    CALL 01        */
  168. pb(OP_GREF); pb(0x08);        /* 0024 05 08    GREF 08 ; *toplevel*    */
  169. pb(OP_CALL); pb(0x00);        /* 0026 0c 00    CALL 00        */
  170.  
  171.     setvalue(getelement(code,1),cvclosure(code,NIL));
  172. }
  173.  
  174. /* xlsymbols - lookup/enter all symbols used by the runtime system */
  175. xlsymbols()
  176. {
  177.     LVAL sym;
  178.     
  179.     /* top-level procedure symbol */
  180.     s_eval = xlenter("EVAL");
  181.     
  182.     /* enter the symbols used by the system */
  183.     true         = xlenter("#T");
  184.     s_unbound     = xlenter("*UNBOUND*");
  185.     s_unassigned = xlenter("#!UNASSIGNED");
  186.  
  187.     /* enter the i/o symbols */
  188.     s_stdin  = xlenter("*STANDARD-INPUT*");
  189.     s_stdout = xlenter("*STANDARD-OUTPUT*");
  190.     s_stderr = xlenter("*ERROR-OUTPUT*");
  191.     
  192.     /* enter the symbols used by the printer */
  193.     s_fixfmt = xlenter("*FIXNUM-FORMAT*");
  194.     s_flofmt = xlenter("*FLONUM-FORMAT*");
  195.  
  196.     /* enter the lambda list keywords */
  197.     lk_optional = xlenter("#!OPTIONAL");
  198.     lk_rest     = xlenter("#!REST");
  199.  
  200.     /* enter symbols needed by the reader */
  201.     c_lpar   = xlenter("(");
  202.     c_rpar   = xlenter(")");
  203.     c_dot    = xlenter(".");
  204.     c_quote  = xlenter("'");
  205.     s_quote  = xlenter("QUOTE");
  206.  
  207.     /* 'else' is a useful synonym for #t in cond clauses */
  208.     sym = xlenter("ELSE");
  209.     setvalue(sym,true);
  210.  
  211.     /* setup stdin/stdout/stderr */
  212.     setvalue(s_stdin,cvport(stdin,PF_INPUT));
  213.     setvalue(s_stdout,cvport(stdout,PF_OUTPUT));
  214.     setvalue(s_stderr,cvport(stderr,PF_OUTPUT));
  215.  
  216.     /* enter *print-case* and its keywords */
  217.     k_upcase    = xlenter("UPCASE");
  218.     k_downcase    = xlenter("DOWNCASE");
  219.     s_printcase    = xlenter("*PRINT-CASE*");
  220.  
  221.     /* get the built-in continuation subrs */
  222.     cs_map1 = getvalue(xlenter("%MAP1"));
  223.     cs_foreach1 = getvalue(xlenter("%FOR-EACH1"));
  224.     cs_withfile1 = getvalue(xlenter("%WITH-FILE1"));
  225.     cs_load1 = getvalue(xlenter("%LOAD1"));
  226.     cs_force1 = getvalue(xlenter("%FORCE1"));
  227.  
  228.     /* initialize xsobj.c */
  229.     obsymbols();
  230. }
  231.